home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / assembler / fg_expr.t < prev    next >
Text File  |  1988-02-05  |  4KB  |  82 lines
  1. (herald (assembler fg_expr t 11))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; This "compiles" "expressions" taken from an FG description.
  27.  
  28. (lset *fg-expr-refs* '())
  29.  
  30. (define *fg-expr-syntax-table*
  31.   (make-syntax-table standard-syntax-table '*fg-expr-syntax-table*))
  32.                  
  33. ;;; ? references variables in the FG
  34. (set (syntax-table-entry *fg-expr-syntax-table* '?)
  35.      (macro-expander (? var)
  36.        (if (not (memq var *fg-expr-refs*)) (push *fg-expr-refs* var))
  37.        var))
  38.  
  39. (lset *env-parameter-name* nil)
  40.  
  41. (set (syntax-table-entry *fg-expr-syntax-table* 'from)
  42.      (macro-expander (from mark-var dest-var)
  43.        (if (not (memq mark-var *fg-expr-refs*)) (push *fg-expr-refs* mark-var))
  44.        (if (not (memq dest-var *fg-expr-refs*)) (push *fg-expr-refs* dest-var))
  45.        `(expr-compute-disp ,*env-parameter-name* 
  46.                            ,mark-var
  47.                            ,dest-var)
  48.        ))
  49.  
  50. ;;; Returns s-expr for a procedure, which expects its first argument
  51. ;;; to be the VARS vector.
  52.  
  53. (define (compile-expr expr runenv-shape)
  54.   (let ((env-parameter-name (generate-symbol 'expr-env))
  55.         )
  56.     (bind ((*fg-expr-refs* '())
  57.            (*env-parameter-name* env-parameter-name)
  58.            )
  59.       (let ((code (tas-expand expr *fg-expr-syntax-table*)))
  60.         `(lambda (,env-parameter-name)
  61.            (let ,(map (lambda (v)
  62.                         `(,v (vref ,env-parameter-name
  63.                                    ,(vars-ref runenv-shape v))
  64.                               ))
  65.                       *fg-expr-refs*)
  66.              ,code))))))
  67.                                            
  68.                  
  69. ;;; Returns s-expr for a printer for an FG.
  70.  
  71. (define (compile-print-expr expr parameters runenv-shape)
  72.   (bind ((*fg-expr-refs* '()))
  73.     (let ((env-parameter-name (generate-symbol 'expr-env)))
  74.       (let ((code (tas-expand expr *fg-expr-syntax-table*)))
  75.         `(lambda ,(cons env-parameter-name parameters)
  76.            (let ,(map (lambda (v)
  77.                         `(,v (vref ,env-parameter-name
  78.                                    ,(vars-ref runenv-shape v))
  79.                              ))
  80.                       *fg-expr-refs*)
  81.              ,code))))))
  82.